home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / COMAL / T-COMAL Today / (k)t3.d64 / plot'char.l < prev    next >
Text File  |  2007-02-28  |  2KB  |  114 lines
  1. 8000 // EDIT "PLOT'CHAR.LST"
  2. 8010 DIM DUMMY$ OF 25 // SPACE FOR SUB
  3. 8020 BUILD'SUB
  4. 8030 END 
  5. 8040 PROC PLOT'CHAR(X,Y,C$,C'SET) CLOSED
  6. 8050 IF Y<7 OR Y>199 OR X<0 OR X>312 THEN GOTO EXIT
  7. 8060 IY:=199-INT(Y)
  8. 8070 P:=INT(X) MOD 8
  9. 8080 TWO'TO'P:=2^P; TWO'P'8:=2^(8-P)
  10. 8090 S:=7-(IY MOD 8)
  11. 8100 COLOR:=PEEK(53281)-240+16*PEEK(646)
  12. 8110 C'CD:=ORD(C$)
  13. 8120 IF C'CD=255 THEN C'CD:=126
  14. 8130 CASE (C'CD DIV 32) OF
  15. 8140 WHEN 0,4
  16. 8150 C'CD:=32
  17. 8160 WHEN 2,5,7
  18. 8170 C'CD:=C'CD-64
  19. 8180 WHEN 3
  20. 8190 C'CD:=C'CD-32
  21. 8200 WHEN 6
  22. 8210 C'CD:=C'CD-128
  23. 8220 OTHERWISE 
  24. 8230 ENDCASE 
  25. 8240 CASE C'SET OF
  26. 8250 WHEN 0
  27. 8260 BASE:=53248
  28. 8270 WHEN 1
  29. 8280 BASE:=54272
  30. 8290 WHEN 2
  31. 8300 BASE:=55296
  32. 8310 WHEN 3
  33. 8320 BASE:=56320
  34. 8330 OTHERWISE 
  35. 8340 ENDCASE 
  36. 8350 C'ADDR:=8*C'CD+BASE
  37. 8360 DIS'INT
  38. 8370 I'O:=PEEK(1)
  39. 8380 POKE 1,8*(I'O DIV 8)+(I'O MOD 4)
  40. 8390 CA:=C'ADDR; R:=IY
  41. 8400 CBA:=COLOR'BYTE'ADDR(X,R)
  42. 8410 POKE CBA,COLOR
  43. 8420 IF P<>0 THEN
  44. 8430 POKE CBA+1,COLOR
  45. 8440 ENDIF 
  46. 8450 WHILE R<=IY+S DO
  47. 8460 DOTS:=PEEK(CA)
  48. 8470 CBA:=CELL'BYTE'ADDR(X,R)
  49. 8480 LB:=DOTS DIV TWO'TO'P
  50. 8490 AND'BYTE(CBA,LB)
  51. 8500 IF P<>0 THEN
  52. 8510 RB:=TWO'P'8*(DOTS-LB*TWO'TO'P)
  53. 8520 AND'BYTE(CBA+8,RB)
  54. 8530 ENDIF 
  55. 8540 CA:=CA+1; R:=R+1
  56. 8550 ENDWHILE 
  57. 8560 IF S<=7 THEN
  58. 8570 CBA:=COLOR'BYTE'ADDR(X,R)
  59. 8580 POKE CBA,COLOR
  60. 8590 IF P<>0 THEN
  61. 8600 POKE CBA+1,COLOR
  62. 8610 ENDIF 
  63. 8620 WHILE R<=IY+7 DO
  64. 8630 DOTS:=PEEK(CA)
  65. 8640 CBA:=CELL'BYTE'ADDR(X,R)
  66. 8650 LB:=DOTS DIV TWO'TO'P
  67. 8660 AND'BYTE(CBA,LB)
  68. 8670 IF P<>0 THEN
  69. 8680 RB:=TWO'P'8*(DOTS-LB*TWO'TO'P)
  70. 8690 AND'BYTE(CBA+8,RB)
  71. 8700 ENDIF 
  72. 8710 CA:=CA+1; R:=R+1
  73. 8720 ENDWHILE 
  74. 8730 ENDIF 
  75. 8740 POKE 1,PEEK(1)+4
  76. 8750 ENA'INT
  77. 8760 EXIT:
  78. 8770 ENDPROC PLOT'CHAR
  79. 8780 //
  80. 8790 FUNC CELL'BYTE'ADDR(X,IY) CLOSED
  81. 8800 RETURN 57344+320*(IY DIV 8)+8*(X DIV 8)+(IY MOD 8)
  82. 8810 ENDFUNC CELL'BYTE'ADDR
  83. 8820 //
  84. 8830 FUNC COLOR'BYTE'ADDR(X,IY) CLOSED
  85. 8840 RETURN 55296+40*(IY DIV 8)+X DIV 8
  86. 8850 ENDFUNC COLOR'BYTE'ADDR
  87. 8860 //
  88. 8870 PROC DIS'INT CLOSED
  89. 8880 POKE 56334,2*(PEEK(56334) DIV 2)
  90. 8890 ENDPROC DIS'INT
  91. 8900 //
  92. 8910 PROC ENA'INT CLOSED
  93. 8920 POKE 56334,PEEK(56334)+1
  94. 8930 ENDPROC ENA'INT
  95. 8940 //
  96. 8950 PROC AND'BYTE(ADDR,BYTE) CLOSED
  97. 8960 POKE 251,(ADDR MOD 256)
  98. 8970 POKE 252,(ADDR DIV 256)
  99. 8980 POKE 253,BYTE
  100. 8990 SYS 45031
  101. 9000 ENDPROC AND'BYTE
  102. 9010 //
  103. 9020 PROC BUILD'SUB CLOSED
  104. 9030 B:=45031
  105. 9040 FOR A:=B TO B+24 DO
  106. 9050 READ N
  107. 9060 POKE A,N
  108. 9070 ENDFOR A
  109. 9080 DATA 120,165,1,133,254,41,249
  110. 9090 DATA 9,1,133,1,160,0,177,251
  111. 9100 DATA 5,253,145,251
  112. 9110 DATA 165,254,133,1,88,96
  113. 9120 ENDPROC BUILD'SUB
  114.